home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / tcl / tcl70b2.lha / tcl7.0b2 / tclCmdAH.c < prev    next >
C/C++ Source or Header  |  1993-07-17  |  24KB  |  959 lines
  1. /* 
  2.  * tclCmdAH.c --
  3.  *
  4.  *    This file contains the top-level command routines for most of
  5.  *    the Tcl built-in commands whose names begin with the letters
  6.  *    A to H.
  7.  *
  8.  * Copyright (c) 1987-1993 The Regents of the University of California.
  9.  * All rights reserved.
  10.  *
  11.  * Permission is hereby granted, without written agreement and without
  12.  * license or royalty fees, to use, copy, modify, and distribute this
  13.  * software and its documentation for any purpose, provided that the
  14.  * above copyright notice and the following two paragraphs appear in
  15.  * all copies of this software.
  16.  * 
  17.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  18.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  19.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  20.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  21.  *
  22.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  23.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  24.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  25.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  26.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  27.  */
  28.  
  29. #ifndef lint
  30. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdAH.c,v 1.90 93/07/17 15:25:20 ouster Exp $ SPRITE (Berkeley)";
  31. #endif
  32.  
  33. #include "tclInt.h"
  34.  
  35.  
  36. /*
  37.  *----------------------------------------------------------------------
  38.  *
  39.  * Tcl_BreakCmd --
  40.  *
  41.  *    This procedure is invoked to process the "break" Tcl command.
  42.  *    See the user documentation for details on what it does.
  43.  *
  44.  * Results:
  45.  *    A standard Tcl result.
  46.  *
  47.  * Side effects:
  48.  *    See the user documentation.
  49.  *
  50.  *----------------------------------------------------------------------
  51.  */
  52.  
  53.     /* ARGSUSED */
  54. int
  55. Tcl_BreakCmd(dummy, interp, argc, argv)
  56.     ClientData dummy;            /* Not used. */
  57.     Tcl_Interp *interp;            /* Current interpreter. */
  58.     int argc;                /* Number of arguments. */
  59.     char **argv;            /* Argument strings. */
  60. {
  61.     if (argc != 1) {
  62.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  63.         argv[0], "\"", (char *) NULL);
  64.     return TCL_ERROR;
  65.     }
  66.     return TCL_BREAK;
  67. }
  68.  
  69. /*
  70.  *----------------------------------------------------------------------
  71.  *
  72.  * Tcl_CaseCmd --
  73.  *
  74.  *    This procedure is invoked to process the "case" Tcl command.
  75.  *    See the user documentation for details on what it does.
  76.  *
  77.  * Results:
  78.  *    A standard Tcl result.
  79.  *
  80.  * Side effects:
  81.  *    See the user documentation.
  82.  *
  83.  *----------------------------------------------------------------------
  84.  */
  85.  
  86.     /* ARGSUSED */
  87. int
  88. Tcl_CaseCmd(dummy, interp, argc, argv)
  89.     ClientData dummy;            /* Not used. */
  90.     Tcl_Interp *interp;            /* Current interpreter. */
  91.     int argc;                /* Number of arguments. */
  92.     char **argv;            /* Argument strings. */
  93. {
  94.     int i, result;
  95.     int body;
  96.     char *string;
  97.     int caseArgc, splitArgs;
  98.     char **caseArgv;
  99.  
  100.     if (argc < 3) {
  101.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  102.         argv[0], " string ?in? patList body ... ?default body?\"",
  103.         (char *) NULL);
  104.     return TCL_ERROR;
  105.     }
  106.     string = argv[1];
  107.     body = -1;
  108.     if (strcmp(argv[2], "in") == 0) {
  109.     i = 3;
  110.     } else {
  111.     i = 2;
  112.     }
  113.     caseArgc = argc - i;
  114.     caseArgv = argv + i;
  115.  
  116.     /*
  117.      * If all of the pattern/command pairs are lumped into a single
  118.      * argument, split them out again.
  119.      */
  120.  
  121.     splitArgs = 0;
  122.     if (caseArgc == 1) {
  123.     result = Tcl_SplitList(interp, caseArgv[0], &caseArgc, &caseArgv);
  124.     if (result != TCL_OK) {
  125.         return result;
  126.     }
  127.     splitArgs = 1;
  128.     }
  129.  
  130.     for (i = 0; i < caseArgc; i += 2) {
  131.     int patArgc, j;
  132.     char **patArgv;
  133.     register char *p;
  134.  
  135.     if (i == (caseArgc-1)) {
  136.         interp->result = "extra case pattern with no body";
  137.         result = TCL_ERROR;
  138.         goto cleanup;
  139.     }
  140.  
  141.     /*
  142.      * Check for special case of single pattern (no list) with
  143.      * no backslash sequences.
  144.      */
  145.  
  146.     for (p = caseArgv[i]; *p != 0; p++) {
  147.         if (isspace(*p) || (*p == '\\')) {
  148.         break;
  149.         }
  150.     }
  151.     if (*p == 0) {
  152.         if ((*caseArgv[i] == 'd')
  153.             && (strcmp(caseArgv[i], "default") == 0)) {
  154.         body = i+1;
  155.         }
  156.         if (Tcl_StringMatch(string, caseArgv[i])) {
  157.         body = i+1;
  158.         goto match;
  159.         }
  160.         continue;
  161.     }
  162.  
  163.     /*
  164.      * Break up pattern lists, then check each of the patterns
  165.      * in the list.
  166.      */
  167.  
  168.     result = Tcl_SplitList(interp, caseArgv[i], &patArgc, &patArgv);
  169.     if (result != TCL_OK) {
  170.         goto cleanup;
  171.     }
  172.     for (j = 0; j < patArgc; j++) {
  173.         if (Tcl_StringMatch(string, patArgv[j])) {
  174.         body = i+1;
  175.         break;
  176.         }
  177.     }
  178.     ckfree((char *) patArgv);
  179.     if (j < patArgc) {
  180.         break;
  181.     }
  182.     }
  183.  
  184.     match:
  185.     if (body != -1) {
  186.     result = Tcl_Eval(interp, caseArgv[body]);
  187.     if (result == TCL_ERROR) {
  188.         char msg[100];
  189.         sprintf(msg, "\n    (\"%.50s\" arm line %d)", caseArgv[body-1],
  190.             interp->errorLine);
  191.         Tcl_AddErrorInfo(interp, msg);
  192.     }
  193.     goto cleanup;
  194.     }
  195.  
  196.     /*
  197.      * Nothing matched:  return nothing.
  198.      */
  199.  
  200.     result = TCL_OK;
  201.  
  202.     cleanup:
  203.     if (splitArgs) {
  204.     ckfree((char *) caseArgv);
  205.     }
  206.     return result;
  207. }
  208.  
  209. /*
  210.  *----------------------------------------------------------------------
  211.  *
  212.  * Tcl_CatchCmd --
  213.  *
  214.  *    This procedure is invoked to process the "catch" Tcl command.
  215.  *    See the user documentation for details on what it does.
  216.  *
  217.  * Results:
  218.  *    A standard Tcl result.
  219.  *
  220.  * Side effects:
  221.  *    See the user documentation.
  222.  *
  223.  *----------------------------------------------------------------------
  224.  */
  225.  
  226.     /* ARGSUSED */
  227. int
  228. Tcl_CatchCmd(dummy, interp, argc, argv)
  229.     ClientData dummy;            /* Not used. */
  230.     Tcl_Interp *interp;            /* Current interpreter. */
  231.     int argc;                /* Number of arguments. */
  232.     char **argv;            /* Argument strings. */
  233. {
  234.     int result;
  235.  
  236.     if ((argc != 2) && (argc != 3)) {
  237.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  238.         argv[0], " command ?varName?\"", (char *) NULL);
  239.     return TCL_ERROR;
  240.     }
  241.     result = Tcl_Eval(interp, argv[1]);
  242.     if (argc == 3) {
  243.     if (Tcl_SetVar(interp, argv[2], interp->result, 0) == NULL) {
  244.         Tcl_SetResult(interp, "couldn't save command result in variable",
  245.             TCL_STATIC);
  246.         return TCL_ERROR;
  247.     }
  248.     }
  249.     Tcl_ResetResult(interp);
  250.     sprintf(interp->result, "%d", result);
  251.     return TCL_OK;
  252. }
  253.  
  254. /*
  255.  *----------------------------------------------------------------------
  256.  *
  257.  * Tcl_ConcatCmd --
  258.  *
  259.  *    This procedure is invoked to process the "concat" Tcl command.
  260.  *    See the user documentation for details on what it does.
  261.  *
  262.  * Results:
  263.  *    A standard Tcl result.
  264.  *
  265.  * Side effects:
  266.  *    See the user documentation.
  267.  *
  268.  *----------------------------------------------------------------------
  269.  */
  270.  
  271.     /* ARGSUSED */
  272. int
  273. Tcl_ConcatCmd(dummy, interp, argc, argv)
  274.     ClientData dummy;            /* Not used. */
  275.     Tcl_Interp *interp;            /* Current interpreter. */
  276.     int argc;                /* Number of arguments. */
  277.     char **argv;            /* Argument strings. */
  278. {
  279.     if (argc == 1) {
  280.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  281.         " arg ?arg ...?\"", (char *) NULL);
  282.     return TCL_ERROR;
  283.     }
  284.  
  285.     interp->result = Tcl_Concat(argc-1, argv+1);
  286.     interp->freeProc = (Tcl_FreeProc *) free;
  287.     return TCL_OK;
  288. }
  289.  
  290. /*
  291.  *----------------------------------------------------------------------
  292.  *
  293.  * Tcl_ContinueCmd --
  294.  *
  295.  *    This procedure is invoked to process the "continue" Tcl command.
  296.  *    See the user documentation for details on what it does.
  297.  *
  298.  * Results:
  299.  *    A standard Tcl result.
  300.  *
  301.  * Side effects:
  302.  *    See the user documentation.
  303.  *
  304.  *----------------------------------------------------------------------
  305.  */
  306.  
  307.     /* ARGSUSED */
  308. int
  309. Tcl_ContinueCmd(dummy, interp, argc, argv)
  310.     ClientData dummy;            /* Not used. */
  311.     Tcl_Interp *interp;            /* Current interpreter. */
  312.     int argc;                /* Number of arguments. */
  313.     char **argv;            /* Argument strings. */
  314. {
  315.     if (argc != 1) {
  316.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  317.         "\"", (char *) NULL);
  318.     return TCL_ERROR;
  319.     }
  320.     return TCL_CONTINUE;
  321. }
  322.  
  323. /*
  324.  *----------------------------------------------------------------------
  325.  *
  326.  * Tcl_ErrorCmd --
  327.  *
  328.  *    This procedure is invoked to process the "error" Tcl command.
  329.  *    See the user documentation for details on what it does.
  330.  *
  331.  * Results:
  332.  *    A standard Tcl result.
  333.  *
  334.  * Side effects:
  335.  *    See the user documentation.
  336.  *
  337.  *----------------------------------------------------------------------
  338.  */
  339.  
  340.     /* ARGSUSED */
  341. int
  342. Tcl_ErrorCmd(dummy, interp, argc, argv)
  343.     ClientData dummy;            /* Not used. */
  344.     Tcl_Interp *interp;            /* Current interpreter. */
  345.     int argc;                /* Number of arguments. */
  346.     char **argv;            /* Argument strings. */
  347. {
  348.     Interp *iPtr = (Interp *) interp;
  349.  
  350.     if ((argc < 2) || (argc > 4)) {
  351.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  352.         " message ?errorInfo? ?errorCode?\"", (char *) NULL);
  353.     return TCL_ERROR;
  354.     }
  355.     if ((argc >= 3) && (argv[2][0] != 0)) {
  356.     Tcl_AddErrorInfo(interp, argv[2]);
  357.     iPtr->flags |= ERR_ALREADY_LOGGED;
  358.     }
  359.     if (argc == 4) {
  360.     Tcl_SetVar2(interp, "errorCode", (char *) NULL, argv[3],
  361.         TCL_GLOBAL_ONLY);
  362.     iPtr->flags |= ERROR_CODE_SET;
  363.     }
  364.     Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
  365.     return TCL_ERROR;
  366. }
  367.  
  368. /*
  369.  *----------------------------------------------------------------------
  370.  *
  371.  * Tcl_EvalCmd --
  372.  *
  373.  *    This procedure is invoked to process the "eval" Tcl command.
  374.  *    See the user documentation for details on what it does.
  375.  *
  376.  * Results:
  377.  *    A standard Tcl result.
  378.  *
  379.  * Side effects:
  380.  *    See the user documentation.
  381.  *
  382.  *----------------------------------------------------------------------
  383.  */
  384.  
  385.     /* ARGSUSED */
  386. int
  387. Tcl_EvalCmd(dummy, interp, argc, argv)
  388.     ClientData dummy;            /* Not used. */
  389.     Tcl_Interp *interp;            /* Current interpreter. */
  390.     int argc;                /* Number of arguments. */
  391.     char **argv;            /* Argument strings. */
  392. {
  393.     int result;
  394.     char *cmd;
  395.  
  396.     if (argc < 2) {
  397.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  398.         " arg ?arg ...?\"", (char *) NULL);
  399.     return TCL_ERROR;
  400.     }
  401.     if (argc == 2) {
  402.     result = Tcl_Eval(interp, argv[1]);
  403.     } else {
  404.     
  405.     /*
  406.      * More than one argument:  concatenate them together with spaces
  407.      * between, then evaluate the result.
  408.      */
  409.     
  410.     cmd = Tcl_Concat(argc-1, argv+1);
  411.     result = Tcl_Eval(interp, cmd);
  412.     ckfree(cmd);
  413.     }
  414.     if (result == TCL_ERROR) {
  415.     char msg[60];
  416.     sprintf(msg, "\n    (\"eval\" body line %d)", interp->errorLine);
  417.     Tcl_AddErrorInfo(interp, msg);
  418.     }
  419.     return result;
  420. }
  421.  
  422. /*
  423.  *----------------------------------------------------------------------
  424.  *
  425.  * Tcl_ExprCmd --
  426.  *
  427.  *    This procedure is invoked to process the "expr" Tcl command.
  428.  *    See the user documentation for details on what it does.
  429.  *
  430.  * Results:
  431.  *    A standard Tcl result.
  432.  *
  433.  * Side effects:
  434.  *    See the user documentation.
  435.  *
  436.  *----------------------------------------------------------------------
  437.  */
  438.  
  439.     /* ARGSUSED */
  440. int
  441. Tcl_ExprCmd(dummy, interp, argc, argv)
  442.     ClientData dummy;            /* Not used. */
  443.     Tcl_Interp *interp;            /* Current interpreter. */
  444.     int argc;                /* Number of arguments. */
  445.     char **argv;            /* Argument strings. */
  446. {
  447.     Tcl_DString buffer;
  448.     int i, result;
  449.  
  450.     if (argc < 2) {
  451.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  452.         " arg ?arg ...?\"", (char *) NULL);
  453.     return TCL_ERROR;
  454.     }
  455.  
  456.     if (argc == 2) {
  457.     return Tcl_ExprString(interp, argv[1]);
  458.     }
  459.     Tcl_DStringInit(&buffer);
  460.     Tcl_DStringAppend(&buffer, argv[1], -1);
  461.     for (i = 2; i < argc; i++) {
  462.     Tcl_DStringAppend(&buffer, " ", 1);
  463.     Tcl_DStringAppend(&buffer, argv[i], -1);
  464.     }
  465.     result = Tcl_ExprString(interp, buffer.string);
  466.     Tcl_DStringFree(&buffer);
  467.     return result;
  468. }
  469.  
  470. /*
  471.  *----------------------------------------------------------------------
  472.  *
  473.  * Tcl_ForCmd --
  474.  *
  475.  *    This procedure is invoked to process the "for" Tcl command.
  476.  *    See the user documentation for details on what it does.
  477.  *
  478.  * Results:
  479.  *    A standard Tcl result.
  480.  *
  481.  * Side effects:
  482.  *    See the user documentation.
  483.  *
  484.  *----------------------------------------------------------------------
  485.  */
  486.  
  487.     /* ARGSUSED */
  488. int
  489. Tcl_ForCmd(dummy, interp, argc, argv)
  490.     ClientData dummy;            /* Not used. */
  491.     Tcl_Interp *interp;            /* Current interpreter. */
  492.     int argc;                /* Number of arguments. */
  493.     char **argv;            /* Argument strings. */
  494. {
  495.     int result, value;
  496.  
  497.     if (argc != 5) {
  498.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  499.         " start test next command\"", (char *) NULL);
  500.     return TCL_ERROR;
  501.     }
  502.  
  503.     result = Tcl_Eval(interp, argv[1]);
  504.     if (result != TCL_OK) {
  505.     if (result == TCL_ERROR) {
  506.         Tcl_AddErrorInfo(interp, "\n    (\"for\" initial command)");
  507.     }
  508.     return result;
  509.     }
  510.     while (1) {
  511.     result = Tcl_ExprBoolean(interp, argv[2], &value);
  512.     if (result != TCL_OK) {
  513.         return result;
  514.     }
  515.     if (!value) {
  516.         break;
  517.     }
  518.     result = Tcl_Eval(interp, argv[4]);
  519.     if (result == TCL_CONTINUE) {
  520.         result = TCL_OK;
  521.     } else if (result != TCL_OK) {
  522.         if (result == TCL_ERROR) {
  523.         char msg[60];
  524.         sprintf(msg, "\n    (\"for\" body line %d)", interp->errorLine);
  525.         Tcl_AddErrorInfo(interp, msg);
  526.         }
  527.         break;
  528.     }
  529.     result = Tcl_Eval(interp, argv[3]);
  530.     if (result == TCL_BREAK) {
  531.         break;
  532.     } else if (result != TCL_OK) {
  533.         if (result == TCL_ERROR) {
  534.         Tcl_AddErrorInfo(interp, "\n    (\"for\" loop-end command)");
  535.         }
  536.         return result;
  537.     }
  538.     }
  539.     if (result == TCL_BREAK) {
  540.     result = TCL_OK;
  541.     }
  542.     if (result == TCL_OK) {
  543.     Tcl_ResetResult(interp);
  544.     }
  545.     return result;
  546. }
  547.  
  548. /*
  549.  *----------------------------------------------------------------------
  550.  *
  551.  * Tcl_ForeachCmd --
  552.  *
  553.  *    This procedure is invoked to process the "foreach" Tcl command.
  554.  *    See the user documentation for details on what it does.
  555.  *
  556.  * Results:
  557.  *    A standard Tcl result.
  558.  *
  559.  * Side effects:
  560.  *    See the user documentation.
  561.  *
  562.  *----------------------------------------------------------------------
  563.  */
  564.  
  565.     /* ARGSUSED */
  566. int
  567. Tcl_ForeachCmd(dummy, interp, argc, argv)
  568.     ClientData dummy;            /* Not used. */
  569.     Tcl_Interp *interp;            /* Current interpreter. */
  570.     int argc;                /* Number of arguments. */
  571.     char **argv;            /* Argument strings. */
  572. {
  573.     int listArgc, i, result;
  574.     char **listArgv;
  575.  
  576.     if (argc != 4) {
  577.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  578.         " varName list command\"", (char *) NULL);
  579.     return TCL_ERROR;
  580.     }
  581.  
  582.     /*
  583.      * Break the list up into elements, and execute the command once
  584.      * for each value of the element.
  585.      */
  586.  
  587.     result = Tcl_SplitList(interp, argv[2], &listArgc, &listArgv);
  588.     if (result != TCL_OK) {
  589.     return result;
  590.     }
  591.     for (i = 0; i < listArgc; i++) {
  592.     if (Tcl_SetVar(interp, argv[1], listArgv[i], 0) == NULL) {
  593.         Tcl_SetResult(interp, "couldn't set loop variable", TCL_STATIC);
  594.         result = TCL_ERROR;
  595.         break;
  596.     }
  597.  
  598.     result = Tcl_Eval(interp, argv[3]);
  599.     if (result != TCL_OK) {
  600.         if (result == TCL_CONTINUE) {
  601.         result = TCL_OK;
  602.         } else if (result == TCL_BREAK) {
  603.         result = TCL_OK;
  604.         break;
  605.         } else if (result == TCL_ERROR) {
  606.         char msg[100];
  607.         sprintf(msg, "\n    (\"foreach\" body line %d)",
  608.             interp->errorLine);
  609.         Tcl_AddErrorInfo(interp, msg);
  610.         break;
  611.         } else {
  612.         break;
  613.         }
  614.     }
  615.     }
  616.     ckfree((char *) listArgv);
  617.     if (result == TCL_OK) {
  618.     Tcl_ResetResult(interp);
  619.     }
  620.     return result;
  621. }
  622.  
  623. /*
  624.  *----------------------------------------------------------------------
  625.  *
  626.  * Tcl_FormatCmd --
  627.  *
  628.  *    This procedure is invoked to process the "format" Tcl command.
  629.  *    See the user documentation for details on what it does.
  630.  *
  631.  * Results:
  632.  *    A standard Tcl result.
  633.  *
  634.  * Side effects:
  635.  *    See the user documentation.
  636.  *
  637.  *----------------------------------------------------------------------
  638.  */
  639.  
  640.     /* ARGSUSED */
  641. int
  642. Tcl_FormatCmd(dummy, interp, argc, argv)
  643.     ClientData dummy;            /* Not used. */
  644.     Tcl_Interp *interp;            /* Current interpreter. */
  645.     int argc;                /* Number of arguments. */
  646.     char **argv;            /* Argument strings. */
  647. {
  648.     register char *format;    /* Used to read characters from the format
  649.                  * string. */
  650.     char newFormat[40];        /* A new format specifier is generated here. */
  651.     int width;            /* Field width from field specifier, or 0 if
  652.                  * no width given. */
  653.     int precision;        /* Field precision from field specifier, or 0
  654.                  * if no precision given. */
  655.     int size;            /* Number of bytes needed for result of
  656.                  * conversion, based on type of conversion
  657.                  * ("e", "s", etc.) and width from above. */
  658.     char *oneWordValue = NULL;    /* Used to hold value to pass to sprintf, if
  659.                  * it's a one-word value. */
  660.     double twoWordValue;    /* Used to hold value to pass to sprintf if
  661.                  * it's a two-word value. */
  662.     int useTwoWords;        /* 0 means use oneWordValue, 1 means use
  663.                  * twoWordValue. */
  664.     char *dst = interp->result;    /* Where result is stored.  Starts off at
  665.                  * interp->resultSpace, but may get dynamically
  666.                  * re-allocated if this isn't enough. */
  667.     int dstSize = 0;        /* Number of non-null characters currently
  668.                  * stored at dst. */
  669.     int dstSpace = TCL_RESULT_SIZE;
  670.                 /* Total amount of storage space available
  671.                  * in dst (not including null terminator. */
  672.     int noPercent;        /* Special case for speed:  indicates there's
  673.                  * no field specifier, just a string to copy. */
  674.     int argIndex;        /* Index of argument to substitute next. */
  675.     int gotXpg = 0;        /* Non-zero means that an XPG3 %n$-style
  676.                  * specifier has been seen. */
  677.     int gotSequential = 0;    /* Non-zero means that a regular sequential
  678.                  * (non-XPG3) conversion specifier has been
  679.                  * seen. */
  680.     int useShort;        /* Value to be printed is short (half word). */
  681.     char *end;            /* Used to locate end of numerical fields. */
  682.  
  683.     /*
  684.      * This procedure is a bit nasty.  The goal is to use sprintf to
  685.      * do most of the dirty work.  There are several problems:
  686.      * 1. this procedure can't trust its arguments.
  687.      * 2. we must be able to provide a large enough result area to hold
  688.      *    whatever's generated.  This is hard to estimate.
  689.      * 2. there's no way to move the arguments from argv to the call
  690.      *    to sprintf in a reasonable way.  This is particularly nasty
  691.      *    because some of the arguments may be two-word values (doubles).
  692.      * So, what happens here is to scan the format string one % group
  693.      * at a time, making many individual calls to sprintf.
  694.      */
  695.  
  696.     if (argc < 2) {
  697.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  698.         " formatString ?arg arg ...?\"", (char *) NULL);
  699.     return TCL_ERROR;
  700.     }
  701.     argIndex = 2;
  702.     for (format = argv[1]; *format != 0; ) {
  703.     register char *newPtr = newFormat;
  704.  
  705.     width = precision = useTwoWords = noPercent = useShort = 0;
  706.  
  707.     /*
  708.      * Get rid of any characters before the next field specifier.
  709.      */
  710.  
  711.     if (*format != '%') {
  712.         register char *p;
  713.  
  714.         oneWordValue = p = format;
  715.         while ((*format != '%') && (*format != 0)) {
  716.         *p = *format;
  717.         p++;
  718.         format++;
  719.         }
  720.         size = p - oneWordValue;
  721.         noPercent = 1;
  722.         goto doField;
  723.     }
  724.  
  725.     if (format[1] == '%') {
  726.         oneWordValue = format;
  727.         size = 1;
  728.         noPercent = 1;
  729.         format += 2;
  730.         goto doField;
  731.     }
  732.  
  733.     /*
  734.      * Parse off a field specifier, compute how many characters
  735.      * will be needed to store the result, and substitute for
  736.      * "*" size specifiers.
  737.      */
  738.  
  739.     *newPtr = '%';
  740.     newPtr++;
  741.     format++;
  742.     if (isdigit(*format)) {
  743.         int tmp;
  744.  
  745.         /*
  746.          * Check for an XPG3-style %n$ specification.  Note: there
  747.          * must not be a mixture of XPG3 specs and non-XPG3 specs
  748.          * in the same format string.
  749.          */
  750.  
  751.         tmp = strtoul(format, &end, 10);
  752.         if (*end != '$') {
  753.         goto notXpg;
  754.         }
  755.         format = end+1;
  756.         gotXpg = 1;
  757.         if (gotSequential) {
  758.         goto mixedXPG;
  759.         }
  760.         argIndex = tmp+1;
  761.         if ((argIndex < 2) || (argIndex >= argc)) {
  762.         goto badIndex;
  763.         }
  764.         goto xpgCheckDone;
  765.     }
  766.  
  767.     notXpg:
  768.     gotSequential = 1;
  769.     if (gotXpg) {
  770.         goto mixedXPG;
  771.     }
  772.  
  773.     xpgCheckDone:
  774.     while ((*format == '-') || (*format == '#') || (*format == '0')
  775.         || (*format == ' ') || (*format == '+')) {
  776.         *newPtr = *format;
  777.         newPtr++;
  778.         format++;
  779.     }
  780.     if (isdigit(*format)) {
  781.         width = strtoul(format, &end, 10);
  782.         format = end;
  783.     } else if (*format == '*') {
  784.         if (argIndex >= argc) {
  785.         goto badIndex;
  786.         }
  787.         if (Tcl_GetInt(interp, argv[argIndex], &width) != TCL_OK) {
  788.         goto fmtError;
  789.         }
  790.         argIndex++;
  791.         format++;
  792.     }
  793.     if (width != 0) {
  794.         sprintf(newPtr, "%d", width);
  795.         while (*newPtr != 0) {
  796.         newPtr++;
  797.         }
  798.     }
  799.     if (*format == '.') {
  800.         *newPtr = '.';
  801.         newPtr++;
  802.         format++;
  803.     }
  804.     if (isdigit(*format)) {
  805.         precision = strtoul(format, &end, 10);
  806.         format = end;
  807.     } else if (*format == '*') {
  808.         if (argIndex >= argc) {
  809.         goto badIndex;
  810.         }
  811.         if (Tcl_GetInt(interp, argv[argIndex], &precision) != TCL_OK) {
  812.         goto fmtError;
  813.         }
  814.         argIndex++;
  815.         format++;
  816.     }
  817.     if (precision != 0) {
  818.         sprintf(newPtr, "%d", precision);
  819.         while (*newPtr != 0) {
  820.         newPtr++;
  821.         }
  822.     }
  823.     if (*format == 'l') {
  824.         format++;
  825.     } else if (*format == 'h') {
  826.         useShort = 1;
  827.         *newPtr = 'h';
  828.         newPtr++;
  829.         format++;
  830.     }
  831.     *newPtr = *format;
  832.     newPtr++;
  833.     *newPtr = 0;
  834.     if (argIndex >= argc) {
  835.         goto badIndex;
  836.     }
  837.     switch (*format) {
  838.         case 'i':
  839.         newPtr[-1] = 'd';
  840.         case 'd':
  841.         case 'o':
  842.         case 'u':
  843.         case 'x':
  844.         case 'X':
  845.         if (Tcl_GetInt(interp, argv[argIndex], (int *) &oneWordValue)
  846.             != TCL_OK) {
  847.             goto fmtError;
  848.         }
  849.         size = 40;
  850.         break;
  851.         case 's':
  852.         oneWordValue = argv[argIndex];
  853.         size = strlen(argv[argIndex]);
  854.         break;
  855.         case 'c':
  856.         if (Tcl_GetInt(interp, argv[argIndex], (int *) &oneWordValue)
  857.             != TCL_OK) {
  858.             goto fmtError;
  859.         }
  860.         size = 1;
  861.         break;
  862.         case 'e':
  863.         case 'E':
  864.         case 'f':
  865.         case 'g':
  866.         case 'G':
  867.         if (Tcl_GetDouble(interp, argv[argIndex], &twoWordValue)
  868.             != TCL_OK) {
  869.             goto fmtError;
  870.         }
  871.         useTwoWords = 1;
  872.         size = 320;
  873.         if (precision > 10) {
  874.             size += precision;
  875.         }
  876.         break;
  877.         case 0:
  878.         interp->result =
  879.             "format string ended in middle of field specifier";
  880.         goto fmtError;
  881.         default:
  882.         sprintf(interp->result, "bad field specifier \"%c\"", *format);
  883.         goto fmtError;
  884.     }
  885.     argIndex++;
  886.     format++;
  887.  
  888.     /*
  889.      * Make sure that there's enough space to hold the formatted
  890.      * result, then format it.
  891.      */
  892.  
  893.     doField:
  894.     if (width > size) {
  895.         size = width;
  896.     }
  897.     if ((dstSize + size) > dstSpace) {
  898.         char *newDst;
  899.         int newSpace;
  900.  
  901.         newSpace = 2*(dstSize + size);
  902.         newDst = (char *) ckalloc((unsigned) newSpace+1);
  903.         if (dstSize != 0) {
  904.         memcpy((VOID *) newDst, (VOID *) dst, dstSize);
  905.         }
  906.         if (dstSpace != TCL_RESULT_SIZE) {
  907.         ckfree(dst);
  908.         }
  909.         dst = newDst;
  910.         dstSpace = newSpace;
  911.     }
  912.     if (noPercent) {
  913.         memcpy((VOID *) (dst+dstSize), (VOID *) oneWordValue, size);
  914.         dstSize += size;
  915.         dst[dstSize] = 0;
  916.     } else {
  917.         if (useTwoWords) {
  918.         sprintf(dst+dstSize, newFormat, twoWordValue);
  919.         } else if (useShort) {
  920.         /*
  921.          * The double cast below is needed for a few machines
  922.          * (e.g. Pyramids as of 1/93) that don't like casts
  923.          * directly from pointers to shorts.
  924.          */
  925.  
  926.         sprintf(dst+dstSize, newFormat, (short) (int) oneWordValue);
  927.         } else {
  928.         sprintf(dst+dstSize, newFormat, (char *) oneWordValue);
  929.         }
  930.         dstSize += strlen(dst+dstSize);
  931.     }
  932.     }
  933.  
  934.     interp->result = dst;
  935.     if (dstSpace != TCL_RESULT_SIZE) {
  936.     interp->freeProc = (Tcl_FreeProc *) free;
  937.     } else {
  938.     interp->freeProc = 0;
  939.     }
  940.     return TCL_OK;
  941.  
  942.     mixedXPG:
  943.     interp->result = "cannot mix \"%\" and \"%n$\" conversion specifiers";
  944.     goto fmtError;
  945.  
  946.     badIndex:
  947.     if (gotXpg) {
  948.     interp->result = "\"%n$\" argument index out of range";
  949.     } else {
  950.     interp->result = "not enough arguments for all format specifiers";
  951.     }
  952.  
  953.     fmtError:
  954.     if (dstSpace != TCL_RESULT_SIZE) {
  955.     ckfree(dst);
  956.     }
  957.     return TCL_ERROR;
  958. }
  959.